home *** CD-ROM | disk | FTP | other *** search
/ Deutsche Edition 1 / Deutsche Edition 1.iso / amok / amok_lha / amok17.lha / IFFtoImage / Sources / Fenster.mod < prev    next >
Text File  |  1993-08-15  |  6KB  |  198 lines
  1. IMPLEMENTATION MODULE Fenster;
  2.  
  3. (* Hilfsmodul zur Erstellung einfacher Fenster unter Intuition. *)
  4.  
  5. FROM SYSTEM    IMPORT ADR, LONGSET;
  6. FROM Arts      IMPORT Assert, TermProcedure;
  7. FROM Intuition IMPORT CloseWindow, NewWindow, OpenWindow, WindowPtr,
  8.                       WindowFlagSet, WindowFlags, IDCMPFlagSet,
  9.                       IDCMPFlags,
  10.                       IntuiMessagePtr, ScreenPtr, NewScreen,
  11.                       OpenScreen, customScreen;
  12. FROM Graphics  IMPORT ViewModeSet, RastPortPtr, ViewPortPtr, SetAPen,
  13.                       RectFill, Move, Text, SetRGB4, ViewModes;
  14. FROM Exec      IMPORT Wait, MsgPortPtr, GetMsg, ReplyMsg;
  15.  
  16. CONST
  17.   nul = 00C;
  18.  
  19. VAR
  20.   wp            :WindowPtr;
  21.   s             :ScreenPtr;
  22.  
  23.   
  24. PROCEDURE BildSchirm():ScreenPtr;
  25.   VAR
  26.     ns :NewScreen;
  27.   BEGIN
  28.     WITH ns DO
  29.       leftEdge     := 0;  topEdge := 0;
  30.       width        := 640; height := 256; 
  31.       depth        := 2; 
  32.       detailPen    := 0; blockPen := 1;
  33.       viewModes    := ViewModeSet{hires};
  34.       type         := customScreen;
  35.       font         := NIL;
  36.       defaultTitle := NIL;
  37.       gadgets      := NIL;
  38.       customBitMap := NIL;
  39.     END;
  40.     s := OpenScreen(ns);
  41.     Assert(s#NIL,ADR("Screen geht nicht auf!"));
  42.     RETURN s;
  43.   END BildSchirm;
  44.  
  45.  
  46. PROCEDURE FensterAuf(links,oben,breit,hoch:INTEGER;
  47.                      t:ARRAY OF CHAR;sP:ScreenPtr):WindowPtr;
  48.   VAR
  49.     MyWindow :NewWindow;
  50.   BEGIN
  51.     WITH MyWindow DO
  52.       leftEdge    := links;
  53.       topEdge     := oben;
  54.       width       := breit;
  55.       height      := hoch;
  56.       detailPen   :=   0;
  57.       blockPen    :=   1;
  58.       title       := ADR(t);
  59.       flags       := WindowFlagSet{activate,windowSizing,borderless,
  60.                    windowRefresh,windowDrag,windowClose};
  61.                      (* 'backDrop' ist nicht immer gut, verhindert
  62.                         windowSizing etc.! *)
  63.  
  64.       idcmpFlags  := IDCMPFlagSet{closeWindow};
  65.                                  (* Dieses Flag muß gesetzt werden,
  66.                                     damit vom IntuitionMessagePort
  67.                                     die Nachricht über die Betätigung
  68.                                     des Schließ-Gadgets abgeholt
  69.                                     werden kann.                  *)
  70.       firstGadget := NIL;
  71.       screen      := sP;
  72.       checkMark   := NIL;
  73.       type        := customScreen; (* = Screentyp *)
  74.       bitMap      := NIL;
  75.       minWidth    :=  30;
  76.       minHeight   :=  15;
  77.       maxWidth    := 640;
  78.       maxHeight   := 256;
  79.     END;
  80.   
  81.     wp := OpenWindow(MyWindow);   (* Zeiger wp wird gebraucht, um das Fenster 
  82.                                  mit CloseWindow(wp) wieder schließen zu
  83.                                  können.                                   *)
  84.  
  85.     Assert(wp#NIL,ADR("Fenster geht nicht auf!!!")); 
  86.                                (* Warnung, falls Fenster nicht geöffnet
  87.                                   werden konnte! *)
  88.     RETURN wp;
  89.  
  90.  END FensterAuf;
  91.  
  92.  PROCEDURE Info(up:MsgPortPtr;VAR code:CARDINAL):IDCMPFlagSet;
  93.    VAR
  94.      sig          :LONGSET;
  95.      im,dummy     :IntuiMessagePtr;
  96.      FLAG         :IDCMPFlagSet;
  97.    BEGIN
  98.        dummy := NIL;
  99.        sig := Wait(LONGSET{up^.sigBit});
  100.                                (* Mit Wait auf die Message vom
  101.                                   IntuitionMessagePort warten!        *)
  102.                                   
  103.        im := GetMsg(up);       (* Den Zeiger auf den Message-
  104.                                   Record abholen.                     *)
  105.        code := im^.code;
  106.        FLAG := im^.class;
  107.        ReplyMsg(im);           (* Die Message quittieren, damit
  108.                                   der IntuitionMessagePort nicht
  109.                                   blockiert wird.                     *)
  110.  
  111.        dummy := GetMsg(up);    (* MsgPort ausleeren!                  *)
  112.        WHILE dummy # NIL DO
  113.          ReplyMsg(dummy);
  114.          dummy := GetMsg(up);
  115.        END;
  116.  
  117.        RETURN FLAG;            (* Die Message aus dem Message-
  118.                                   Record holen und an Info abliefern. *)
  119.                                   
  120.    END Info;
  121.  
  122.       
  123. PROCEDURE CLS(rp:RastPortPtr;b,h:INTEGER);
  124.   BEGIN
  125.     SetAPen(rp,0);
  126.     RectFill(rp,1,9,b-12,h-9);
  127.   END CLS;
  128.   
  129.   
  130. PROCEDURE Farben(vp:ViewPortPtr);
  131.   BEGIN
  132.     SetRGB4(vp, 0, 1, 1, 1);
  133.     SetRGB4(vp, 1,14, 0, 5);
  134.     SetRGB4(vp, 2, 0,14, 0);
  135.     SetRGB4(vp, 3, 5, 5,14);
  136.     (* Die Prozedur SetRGB4(vp,nr,rot,grün,blau) setzt im ViewPort vp
  137.        die Farbnummern nr (0 bis 3 bei zwei Bitplanes) auf die Rot-,
  138.        Grün- und Blau-Werte zwischen 0 und 15. Auch Kombinationen,
  139.        z.B. SetRGB4(vp,1,7,8,9) wären möglich.                        *)
  140.   END Farben;
  141.   
  142.      
  143. (* Private *) PROCEDURE Length(t:ARRAY OF CHAR):INTEGER;
  144.   VAR
  145.     i,max :INTEGER;
  146.   BEGIN
  147.     i := 0;
  148.     max := HIGH(t);  (* HIGH(t) ist eine Standard-Funktion, die 
  149.                         die obere Feldgrenze (= den Maximalindex)
  150.                         des offenen Feldes t zurück liefert.          *)
  151.     WHILE (i <= max) AND (t[i] # nul) DO
  152.       i := i+1;
  153.     END;
  154.     RETURN i;
  155.   END Length;
  156.    
  157.  
  158. PROCEDURE Print(rp:RastPortPtr;f,x,y:INTEGER;t:ARRAY OF CHAR);
  159.   BEGIN
  160.     SetAPen(rp,f); (* Setzt den Schreibstift auf die Farbe f (0..3).  *)
  161.     Move(rp,x,y);  (* Bewegt den Schreibstift an die Position (x/y)
  162.                       in Pixel.                                       *)
  163.     Text(rp,ADR(t),Length(t));
  164.                    (* Schreibt den Text t der Länge Length(t) an die
  165.                       vorher mit Move(rp,x,y) festgelegte Position.   *)
  166.   END Print;
  167.  
  168.  
  169. PROCEDURE Echo(rp:RastPortPtr;f,x,y:INTEGER;t:CHAR);
  170.   BEGIN
  171.     SetAPen(rp,f); (* Setzt den Schreibstift auf die Farbe f (0..3).  *)
  172.     Move(rp,x,y);  (* Bewegt den Schreibstift an die Position (x/y)
  173.                       in Pixel.                                       *)
  174.     Text(rp,ADR(t),1);
  175.                    (* Schreibt den Text t der Länge 1 (= CHAR) an die
  176.                       vorher mit Move(rp,x,y) festgelegte Position.   *)
  177.   END Echo;
  178.   
  179.   
  180.  
  181. PROCEDURE GetASCII(up:MsgPortPtr):CARDINAL;
  182.   VAR
  183.     Signal:IDCMPFlagSet;
  184.     kode  :CARDINAL;
  185.     im    :IntuiMessagePtr;
  186.   BEGIN
  187.     LOOP
  188.       Signal := Info(up,kode);
  189.       IF vanillaKey IN Signal THEN EXIT END;
  190.     END; (* LOOP *)
  191.     RETURN kode;
  192.   END GetASCII;
  193.   
  194.  
  195. END Fenster.
  196.                       
  197.       
  198.